00100	TITLE EULER  -  EULER  PRIMITIVES  -  JULY 1972.
00200		
00300	COMMENT /
00400	These primitives preserve the Euler Equation F-E+V = 2*B-2*H;
00500	
00600		INVERT(E);			"|" COMMAND.
00700		EVERT(B);			"¬" COMMAND.
00800		VNEW ← MKEV(F,V);		"E" COMMAND.
00900		ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
01000		VNEW ← ESPLIT(E);		"M" COMMAND.
01100		   F ← KLFE(ENEW);		"K" COMMAND.
01200		   E ← KLEV(VNEW);		"K" COMMAND.
01300		   V ← KLVE(ENEW);     	        "αK" COMMAND.
01400		BNEW ← MKCOPY(B);		"C" COMMAND.
01500		ENEW ← GLUEE(F1,V1,F2,V2);	"J" COMMAND.
01600	/
01700	
01800	;THE EULER PRIMITVES ARE DEPENDENT ON THE WING OPERATIONS.
01900		EXTERN MAKE,KILL
02000		EXTERN MKB,MKF,MKE,MKV
02100		EXTERN KLB,KLF,KLE,KLV,WING
02200		EXTERN WING,LINKED
02300		EXTERN ECW,ECCW,OTHER,OTHER.
02400		EXTERN BODY,FCW,FCCW,VCW,VCCW
02500	
02600	;BIT FOR MARKING EDGES OF A WASP FACE'S WAIST.
02700		↓WASP←←1B5
     

00100	SUBR(INVERT)------------------------------------------------------
00200	BEGIN INVERT
00300		LAC 1,ARG1
00400		MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
00500		MOVNS -3(1)↔MOVNS -2(1)↔MOVNS -1(1)
00600		POP1J
00700	BEND;1/14/73------------------------------------------------------
00800	
00900	;EVERT(B) - TURN BODY INSIDE OUT.
01000	SUBR(EVERT)BODY --------------------------------------------------
01100	BEGIN EVERT; TURN SOMETHING INSIDE OUT.
01200		ACCUMULATORS{B,E}
01300		CDR B,ARG1
01400		TEST B,BBIT↔POP1J
01500		LAC E,B
01600	L1:	PED E,E
01700		TEST E,EBIT↔GO L3
01800		MOVSS 1(E)
01900		MOVS  4(E)↔MOVS 1,5(E)
02000		DAC 1,4(E)↔DAC 5(E)
02100		GO L1
02200	
02300	;PARTS OF THIS BODY.
02400	L3:	SON 1,B↔JUMPE 1,POP1J.
02500	L4:	PUSH P,1↔CALL(EVERT,1)
02700		POP P,1↔LAC B,ARG1
02800		BRO 1,1↔SON 0,B
02900		CAME 0,1↔GO L4↔POP1J
03000	BEND;1/14/73------------------------------------------------------
     

00100	;VNEW ← MKEV(F,V).  "E" COMMAND.
00200	SUBR(MKEV)--------------------------------------------------------
00300	BEGIN	MKEV
00400		ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}
00500	
00600	;CHECK FOR BAD ARGUMENTS.
00700		CDR VNEW,ARG1;FOR BAD RETURNS.
00800		LAC V,ARG1↔TEST(V,VBIT)↔POP2J
00900		LAC F,ARG2↔TEST(F,FBIT)↔POP2J
01000	
01100	;CREATE A NEW EDGE AND VERTEX.
01200		SETQ(B,{BODY,V})
01300		SETQ(VNEW,{MKV,B})
01400		SLACI XWC(V)↔LAPI XWC(VNEW)↔BLT ZWC(VNEW)
01450		LAC 1(V)↔DAC 1(VNEW)
01500		SETQ(ENEW,{MKE,B})
01600	
01700	;MAKE FACE AND VERTEX LINKS.
01800		PED. 	ENEW,VNEW
01900		NFACE.	F,ENEW
02000		PFACE.	F,ENEW
02100		NVT.	VNEW,ENEW
02200		PVT.	V,ENEW
02300	
02400	;CHECK FOR VERTEX BODY CASE.
02500		PED E1,F↔JUMPE E1,[
02600		PED. ENEW,F↔PED. ENEW,V
02700		PCW. ENEW,ENEW↔NCCW. ENEW,ENEW↔GO .+1]
02800	
02900	;LOWER WINGS POINT AT SELF.
03000		NCW. ENEW,ENEW
03100		PCCW. ENEW,ENEW
03200	
03300	;GET THE UPPER WINGS.
03400		PED E1,V↔LAC E2,E1
03500		NFACE 0,E1↔PFACE 1,E1
03600		CAMN 0,1↔GO L2
03700	L1:	LAC E1,E2
03800		SETQ(E2,{ECW,E1,V})
03900		CALL(FCW,E1,V)
04000		CAME 1,F↔GO L1
04100	
04200	;TIE ENEW TO ITS UPPER WINGS.
04300	L2:	PCW. E1,ENEW↔NCCW. E2,ENEW
04400		PVT 0,E1↔CAME 0,V↔GO[PCCW. ENEW,E1↔GO .+2]↔NCCW. ENEW,E1
04500		PVT 0,E2↔CAME 0,V↔GO[NCW.  ENEW,E2↔GO .+2]↔PCW.  ENEW,E2
04600		LAC 1,VNEW↔POP2J
04700		LIT
04800	BEND;1/14/73------------------------------------------------------
     

00100	;ENEW ← MKFE(V1,F,V2);		"J" COMMAND.
00200	SUBR(MKFE)--------------------------------------------------------
00300	BEGIN	MKFE
00400		ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B}
00500	
00600	;FETCH THE ARGUMENTS.
00700		CDR V1,ARG3
00800		CDR  F,ARG2
00900		CDR V2,ARG1
01000	
01100	;DO THE CREATIONS.
01200		SETQ(B,{BODY,F})
01300		SETQ(FNEW,{MKF,B})
01400		SETQ(ENEW,{MKE,B})
01500	
01600	;LINK ENEW.
01700		PED. ENEW,F↔	PED. ENEW,FNEW
01800		PFACE. F,ENEW↔	NFACE. FNEW,ENEW
01900		PVT. V1,ENEW↔ 	NVT. V2,ENEW
02000	
02100	;GET THE UPPER WINGS.
02200		PED E,V1↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02300		GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
02400		CALL(FCW,E0,V1)↔CAME 1,F↔GO L1↔GO .+1]
02500		DAC E0,E1#↔DAC E,E2#
02600	
02700	;GET THE LOWER WINGS.
02800		PED E,V2↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02900		GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
03000		CALL(FCW,E0,V2)↔CAME 1,F↔GO L2↔GO .+1]
03100		DAC E0,E3#↔DAC E,E4#
03200	
03300	COMMENT .   					MKFE MANDALA
03400		        o--------o       o--------o
03500		        |   E2    \     /   E1    |
03600		        |   nccw   \   /   pcw    |
03700		        |           \ /		  |
03800		        |       pvt  ⊗  V1        |
03900		        |            |		  |
04000		        |     FNEW   ENEW    F    |
04100		        |            |		  |
04200		        |       nvt  ⊗  V2	  |
04300			|           / \		  |
04400		        |    ncw   /   \   pccw   |
04500		        |    E3   /     \    E4   |
04600		        o--------o       o--------o
04700	
04800	-----------------------------------------------------------------.
     

00100	;CDR V2'S TAIL REPLACING +F'S WITH FNEW.
00200		LAC E,E3
00300	L3:	MOVS 1,1(E)↔CAME 1,1(E)↔GO L4
00400		PFACE. FNEW,E
00500		PCW E,E↔GO L3
00600	
00700	;CCW FROM V1 REPLACING F'S WITH FNEW.
00800	L4:	LAC E0,E↔LAC E,E2↔SETZM A#↔CAMN E0,E2↔GO L6
00900	L5:	TESTZ E,WASP↔JSR WASPS
01000		NFACE 0,E
01100		CAME F,0
01200		GO[PFACE. FNEW,E↔GO .+2]
01300		   NFACE. FNEW,E
01400		CAME E,E0
01500		GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]
01600	
01700	;LINK THE WINGS.
01800	L6:	CALL(WING,E1,ENEW)
01900		CALL(WING,E2,ENEW)
02000		CALL(WING,E3,ENEW)
02100		CALL(WING,E4,ENEW)
02200	L7:	LAC 1,ENEW↔POP3J
02300	
02400	WASPS:	0
02500	
02600		PCW  1,E↔CAMN 1,A↔GO W1
02700		PCCW 1,E↔CAME 1,A↔GO W2
02800	
02900	W1: 	SETZM A↔MARKZ E,WASP
03000		PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03100		TESTZ E,WASP↔GO W1↔GO @WASPS
03200	
03300	W2:	SETZM A↔MARKZ E,WASP
03400		NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03500		TESTZ E,WASP↔GO W2↔GO @WASPS
03600	
03700		LIT
03800	BEND;1/14/73------------------------------------------------------
     

00100	;VNEW ← ESPLIT(E);		"M" COMMAND.
00200	SUBR(ESPLIT)------------------------------------------------------
00300	BEGIN	ESPLIT
00400		ACCUMULATORS{VNEW,ENEW,B,E,V}
00500	
00600	;CHECK FOR BAD ARGUMENTS.
00700		CDR VNEW,ARG1
00800		LAC E,VNEW
00900		TEST E,EBIT↔GO L1
01000		PVT V,E
01100	
01200	;CREATE A NEW EDGE AND VERTEX.
01300		PBODY B,E
01400		SETQ(VNEW,{MKV,B})
01500		SETQ(ENEW,{MKE,B})
01600		SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01700	
01800	;PLACE VNEW BETWEEN E AND ENEW.
01900		PED 0,V↔CAMN 0,E↔PED. ENEW,V
02000		PED. ENEW,VNEW
02100		PVT 0,E↔PVT. 0,ENEW
02200		PVT. VNEW,E
02300		NVT. VNEW,ENEW
02400		PFACE 0,E↔PFACE. 0,ENEW
02500		NFACE 0,E↔NFACE. 0,ENEW
02600	
02700	;NEW UPPER WINGS ARE LIKE THE OLDE;
02800		PCW 0,E↔CALL(WING,0,ENEW)
02900		NCCW 0,E↔CALL(WING,0,ENEW)
03000	
03100	;EDGES POINT AT EACH OTHER ACROSS VNEW.
03200		NCCW. ENEW,E↔PCW.  ENEW,E
03300		NCW.  E,ENEW↔PCCW. E,ENEW
03400	L1:	LAC 1,VNEW↔POP1J
03500	
03600	BEND;1/14/73------------------------------------------------------ 
     

00100	;F ← KLFE(ENEW);		"K" COMMAND.
00200	SUBR(KLFE)--------------------------------------------------------
00300	BEGIN	KLFE
00400		ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,E,F,B}
00500	
00600	;PICK THINGS UP.
00700		CDR ENEW,ARG1
00800		PFACE F,ENEW↔	NFACE FNEW,ENEW
00900		PVT V1,ENEW↔	NVT V2,ENEW
01000	
01100	;GET THE WINGS.
01200		PCW  E1,ENEW
01300		NCCW E2,ENEW
01400		NCW  E3,ENEW
01500		PCCW E4,ENEW
01600	
01700	;GET RID OF ENEW APPEARANCES IN F & V.
01800		PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
01900		PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
02000		PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F
02100	
02200	;GET RID OF FNEW APPEARANCES
02300		LAC E,E2
02400	L1:	PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
02500		NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
02600		FATAL(KLFE)
02700	L2:	CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]
02800	
02900	;LINK WINGS TOGETHER ABOUT F.
03000		CALL(WING,E2,E1)
03100		CALL(WING,E4,E3)
03200	
03300	;GET RID OF FNEW AND ENEW.
03400		PBODY B,ENEW
03500		CALL(KLF,B,FNEW)
03600		CALL(KLE,B,ENEW)
03700		LAC 1,F↔POP1J
03800	
03900	BEND;1/14/73------------------------------------------------------
     

00100	;E ← KLEV(VNEW);		"K" COMMAND.
00200	SUBR(KLEV)--------------------------------------------------------
00300	BEGIN	KLEV
00400		ACCUMULATORS{E,ENEW,V,VNEW,F,B}
00500		CDR VNEW,ARG1↔PED ENEW,VNEW
00600		SETQ(E,{ECCW,ENEW,VNEW})
00700		CAMN E,ENEW↔GO[SETQ(V,{OTHER,ENEW,VNEW})	;EAT WIRE.
00800		SETQ(E,{ECCW,ENEW,V})↔NCW. E,E↔PCCW. E,E↔GO L1]
00900		CALL(ECCW,E,VNEW)↔CAME 1,ENEW
01000		GO[CALL(KLFE,1)↔GO KLEV]
01100	
01200	;ORIENT EDGES AS IN MANDALA.
01300		NVT 0,ENEW↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,ENEW)
01400		PVT 0,E↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,E)
01500	;TIE E TO ITS NEW VERTEX.
01600		PVT V,ENEW↔ PVT. V,E
01700	;MAKE E'S UPPER WINGS LIKE ENEW'S.
01800		PCW 0,ENEW↔CALL(WING,0,E)
01900		NCCW 0,ENEW↔CALL(WING,0,E)
02000	
02100	;ELIMINATE OCCURENCES OF ENEW IN F & V.
02200	L1:	PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
02300		PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02400		NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02500	;PURGE 'EM.
02600		PBODY B,ENEW
02700		CALL(KLV,B,VNEW)
02800		CALL(KLE,B,ENEW)
02900		LAC 1,E↔SLAC 1(1)↔CAMN 1(1)↔NVT 1,1
02950		POP1J↔LIT
03000	COMMENT .        \  pvt  /	KLEV MANDALA
03100	                  \     /
03200	            nccw   \   /   pcw
03300	                    \ /
03400	                  V  ⊗
03500	                     |
03600	                ENEW |
03700	                     | nvt
03800	                VNEW ⊗
03900	                     | pvt
04000	                   E |
04100	                     |
04200	                     ⊗
04300	                    / \
04400	             ncw   /   \   pccw
04500	                  /     \
04600	                 /  nvt  \					.
04700	BEND;1/14/73------------------------------------------------------
     

00100	; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
00200	SUBR(KLVE)--------------------------------------------------------
00300	BEGIN KLVE
00400		ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,S12}
00500	
00600	;PICK THINGS UP.
00700		CDR E,ARG1↔NVT V1,E↔PVT V2,E
00800		PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E
00900	
01000	;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
01100		PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
01200		NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
01300		PED 0,V2↔CAMN 0,E↔PED. E2,V2
01400	
01500	;REPLACE V1 WITH V2.
01600		LAC A,E3
01700	L1:	PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
01800	  	SETQ(A,{ECCW,A,V2})
01900		CAME A,E↔GO L1
02000	
02100	;SPLICE WINGS TOGETHER.
02200		CALL(WING,E1,E4)
02300		CALL(WING,E2,E3)
02400	
02500	;BURN THE GARBAGE.
02600		PBODY A,E
02700		CALL(KLE,A,E)
02800		CALL(KLV,A,V1)
02900		LAC 1,V2
03000		POP1J
03100		LIT
03200	BEND;1/14/73------------------------------------------------------
03300	COMMENT .  KLVE MANDALA
03400	            E2    \     /   E1
03500	            nccw   \   /   pcw
03600	                    \ /
03700	                pvt  ⊗  V2
03800	                     |
03900	                     |  E
04000	                     |
04100	                nvt  ⊗  V1
04200	                    / \
04300	             ncw   /   \   pccw
04400	             E3   /     \    E4.
     

00100	;BNEW ← MKCOPY(B).
00200	SUBR(MKCOPY)------------------------------------------------------
00300	BEGIN MKCOPY
00600		ACCUMULATORS{B,F,E,V,BNEW,Q,A}
00700		EXTERN WORLD,MKLOCOR
00800		LAC B,ARG1
00900		TEST B,BBIT↔POP1J↔SETQ(BNEW,{MKB})
00950		LOCOR Q,B↔SKIPE Q↔GO[CALL(MKLOCOR)↔LOCOR. 1,BNEW
00975		SLACI XWC(Q)↔LAPI XWC(1)↔BLT KZ(1)↔GO .+1]
01000		LAC B,ARG1↔LAC F,B↔LAC E,B↔LAC V,B
01100	
01200	;FOR ALL THE EDGES OF THE BODY.
01300	L1:	PED E,E↔TEST E,EBIT↔GO L2
01700		SETQ(Q,{MKE,BNEW})↔ALT. Q,E↔GO L1
01800	
01900	;FOR ALL THE FACES OF THE BODY.
02000	L2:	PFACE F,F↔TEST F,FBIT↔GO L3
02100		SETQ(Q,{MKF,BNEW})↔ALT. Q,F
02200		PED A,F↔ALT A,A↔PED. A,Q
02300		LAC QQ(F)↔DAC QQ(Q)↔GO L2
02400	
02500	;FOR ALL THE VERTICES OF THE BODY.
02600	L3:	PVT V,V↔TEST V,VBIT↔GO L4
02700		SETQ(Q,{MKV,BNEW})↔ALT. Q,V
02800		PED A,V↔ALT A,A↔PED. A,Q
02900		SLACI XWC(V)↔LAPI XWC(Q)↔BLT ZWC(Q)↔GO L3
03000	
03100	;FOR ALL THE EDGES OF THE BODY.
03200	L4:	PED E,E↔TEST E,EBIT↔GO L5
03300		ALT Q,E
03400		PVT V,E↔  ALT V,V↔PVT. V,Q
03500		NVT V,E↔  ALT V,V↔NVT. V,Q
03600		PFACE F,E↔ALT F,F↔PFACE. F,Q
03700		NFACE F,E↔ALT F,F↔NFACE. F,Q
03800		NCW A,E↔  ALT A,A↔NCW. A,Q
03900		PCW A,E↔  ALT A,A↔PCW. A,Q
04000		NCCW A,E↔ ALT A,A↔NCCW. A,Q
04100		PCCW A,E↔ ALT A,A↔PCCW. A,Q
04200		GO L4
04300	L5:	SETZ↔LAC 1,BNEW↔LAC E,ARG1
04400	L6:	PED E,E↔TEST E,EBIT↔POP1J
04500		ALT. 0,E↔GO L6
04600	BEND;1/14/73------------------------------------------------------
     

00100	;ENEW ← GLUEE(F1,V1,F2,V2)  -  LIKE TWO MKEV(F,V)'S BACK TO BACK.
00200	SUBR(GLUEE)-------------------------------------------------------
00300	BEGIN GLUEE
00400		Q←1
00500		ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
00600		CDR F1,ARG4↔CDR V1,ARG3
00700		CDR F2,ARG2↔CDR V2,ARG1
00800	;BODY SPLICING.
00900		PED E,F1↔PBODY B,E
01000		PED E,F2
01100	
01200	;REPLACE F2 WITH F1.
01300		PED E,F2↔DAC E,E0#
01400	L1:	PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
01500	        NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
01600		SETQ(E,{ECCW,E,F1})
01700		CAME E,E0↔GO L1
01800		CALL(KLF,B,F2)
01900		
     

00100	COMMENT .				GLUEE MANDALA
00200	
00300		|	|	|
00400		|      +V2	|
00500		|     / | \     |
00505		|    /  |  \    |
00600	NCCW	| E2/   |   \E1 |	PCW
00606	       	|  /    |    \  |
00700		| /  F2 |  F2 \ |
00800		o______ | ______o
00900			|		HOWEVER,
01000		  WASP	| ENEW		GLUEE RETURN'S ENEW INVERTED
01100		o______ | ______o
01200		|\      |      /|
01300		| \  F1 |  F1 / |
01400		|  \    |    /  |
01500	NCW	| E3\   |   /E4 |	PCCW
01600		|    \  |  /    |
01700		|     \ | /     |
01800		|      -V1	|
01900		|	|	|
02000	        |	|	|				.
02100	;EDGE CREATION
02200		SETQ(E,{MKE,B})
02300		MARK E,WASP
02400		NFACE. F1,E↔PFACE. F1,E
02500		NVT. V1,E↔PVT. V2,E
02600	
02700	;MAKE WINGS
02800		SETQ(E1,{ECW,V2,F1})↔PCW.  E1,E
02900		SETQ(E2,{ECW,E1,V2})↔NCCW. E2,E
03000		SETQ(E3,{ECW,V1,F1})↔NCW.  E3,E
03100		SETQ(E4,{ECW,E3,V1})↔PCCW. E4,E
03200	
03300		PVT Q,E1↔CAME Q,V2↔GO[PCCW. E,E1↔GO .+2]↔NCCW. E,E1
03400		PVT Q,E2↔CAME Q,V2↔GO[NCW.  E,E2↔GO .+2]↔PCW.  E,E2
03500		PVT Q,E3↔CAME Q,V1↔GO[PCCW. E,E3↔GO .+2]↔NCCW. E,E3
03600		PVT Q,E4↔CAME Q,V1↔GO[NCW.  E,E4↔GO .+2]↔PCW.  E,E4
03700	
03800	;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
03900		CAME E1,E2↔GO L2
04000		MARK E1,WASP↔PVT V1,E1↔PED E1,V1
04100		MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5
04200	
04300	L2:	LAC Q,E↔CALL(INVERT,Q)↔POP4J
04400		LIT
04500	BEND;1/14/73------------------------------------------------------
     

00100	SUBR(GLUE)F1,F2---------------------------------------------------
00200	BEGIN GLUEFF;GLUE TWO FACES TOGETHER - BGB 10 FEBRUARY 1973.
00300		EXTERN DISTAN
00400	;ARGUMENTS MUST BE FACES WITH THE SAME NUMBER OF VERTICES.
00500		LAC 1,ARG1↔DAC 1,F1↔TEST 1,FBIT↔POP2J
00600		LAC 1,ARG2↔DAC 1,F2↔TEST 1,FBIT↔POP2J
00700		LAC 1,F1↔PED 2,1↔DAC 2,E↔DAC 2,E0↔LACI 10,1
00800	L1:	SETQ(E,{ECCW,E,F1})↔CAME 1,E0↔AOJA 10,L1↔DAC 10,NN
00900		LAC 1,F2↔PED 2,1↔DAC 2,E↔DAC 2,E0↔SOS 10
01000	L2:	SETQ(E,{ECCW,E,F2})↔CAME 1,E0↔SOJA 10,L2↔SKIPE 10↔POP2J
01100	
01200	;FIND V2 CLOSEST TO V1.
01300		LAC 1,F1↔PED 2,1↔SETQ(V1,{VCW,2,1})
01400		HRLOI 377777↔DAC MIN
01500		SETZM LIST1↔SETZM LIST2
01600	L3:	SETQ(V,{VCW,E,F2})
01700		CALL(DISTAN,V,V1)
01800		CAMGE 1,MIN↔GO[DAC 1,MIN↔LAC V↔DAC V2↔GO .+1]
01900		LAC 1,E↔LAC LIST1↔DAP -1(1)↔DAC 1,LIST1
02000		LAC 1,V↔LAC LIST2↔DAP -1(1)↔DAC 1,LIST2
02100		SETQ(E,{ECCW,E,F2})
02200		CAME 1,E0↔GO L3
02300		CALL(GLUEE,F1,V1,F2,V2)
02400		CALL(INVERT,1)
02500	
02600	;CLOSE UP THE GAP.
02700		SOS NN
02800	L4:	PCCW 0,1↔PUSH P,0↔PCW 0,1↔PUSH P,0
02900		SETQ(V2,{OTHER,V2})↔SETQ(V1,{OTHER,V1})
03000		CALL(MKFE,V2,F1,V1)↔SOSLE NN↔GO L4
03100	
03200	;NOW KILL ALL THOSE EDGES.
03300	L5:	SKIPN 1,LIST1↔GO L6↔CDR 0,-1(1)↔DAC 0,LIST1
03400		CALL(KLFE,1)↔GO L5
03500	L6:	SKIPN 1,LIST2↔GO L7↔CDR 0,-1(1)↔DAC 0,LIST2
03600		CALL(KLEV,1)↔GO L6
03700	
03800	L7:	LAC 1,F1↔PED 1,1↔PBODY 1,1
03900		POP2J
04000	DECLARE{F1,F2,V,V1,V2,NN,E,E0,MIN,LIST1,LIST2}
04100	BEND;2/10/73------------------------------------------------------
     

00100	SUBR(SWEEP)FACE,FLAG----------------------------------------------
00200	BEGIN SWEEP
00300	
00400	;TEST FOR VALID ARGUMENT.
00500		LAC 1,ARG2↔DAC 1,F↔TEST 1,FBIT↔POP2J
00600		PED 2,1↔DAC 2,E↔SKIPN 2↔POP2J
00700		TEST 2,EBIT↔POP2J
00800	
00900	;TEST FOR SPECIAL CASES.
01000		PCW 3,2↔CAMN 3,2↔GO SWEEP2		;WIRE SWEEP CASE.
01100		SETZM E0↔NCNT 0,1↔DACM NN
01200		SKIPE↔SETZM ARG1
01300	
01400	;MAKE FIRST SPOKE.
01500		CALL(VCW,E,F)↔DAC 1,U0↔DAC 1,U1
01600		CALL(MKEV,F,U0)↔DAC 1,V0↔DAC 1,V1
01700	
01800	;COPY FACE PERIMETER LOOP.
01900	L1:	SETQ(U2,{VCCW,E,F})		;ADVANCE ALONG RIM.
02000		SETQ(E,{ECCW,E,F})
02100		LAC 1,U2↔CAME 1,U0		;MAKE NEXT SPOKE.
02200		GO[CALL(MKEV,F,U2)↔GO .+2]
02300		LAC 1,V0↔DAC 1,V2
02400		CALL(MKFE,V1,F,V2)		;CONNECT SPOKES.
02500		SKIPN E0↔DAC 1,E0		;NEW FIRST EDGE.
02600	
02700	;SPLIT NEW FACE TO MAKE PRISMOIDS.
02800		NFACE 0,1
02900		SKIPGE ARG1↔GO[CALL(MKFE,V1,0,U2)↔GO .+3] ;CW -1.
03000		SKIPLE ARG1↔GO[CALL(MKFE,U1,0,V2)↔GO .+1] ;CCW +1.
03100	
03200	;TEST FOR END OF COPY LOOP.
03300		LAC V2↔DAC V1
03400		LAC U2↔DAC U1
03500		SOSN NN↔GO .+3
03600		CAME U0↔GO L1		;EXIT WHEN NN=0 OR U2=U0
03700	;EXIT.
03800		LAC 0,E0↔LAC 1,F
03900		PED. 0,1↔POP2J
04000	
04100	DECLARE{F,E,E0,U0,U1,U2,V0,V1,V2,NN}
04200	COMMENT .	U2 o----------o U1	FACE SWEEP MANDALA
04300			  / \        / \
04400		         /   \ FNEW /   \
04500		        /     \____/     \
04600		       /     v2    v1	  \
04700	              /         F          \.
04800	BEND;2/7/73-------------------------------------------------------
     

00100	SWEEP2:;FACE,FLAG-------------------------------------------------
00200	BEGIN SWEEP2;WIRE FACE SWEEP - BGB - 7 FEB 1973.
00300	
00400	;COUNT THE EDGES IN THE WIRE.
00500		LAC 3,ARG2↔DAC 3,FACE		;FACE
00600		PED 1,3↔LACI 0,1		;EDGE & NCNT.
00700		LAC 2,1↔NCW 1,1
00800		CAME 1,2↔AOJA 0,.-3		;COUNT THE EDGES.
00900	
01000	;MAKE "BOTTOM" EDGE.
01100		DAC 1,E				;LAST EDGE.
01200		NCNT. 0,3↔DAC NN
01300		NVT 1,1				;LAST VERTEX OF THE WIRE.
01400		SETQ(V2,{MKEV,FACE,1})		;BOTTOM EDGE.
01500	
01600	;COPY THE WIRE.
01700	L1:	SETQ(V2,{MKEV,FACE,V2})
01800		LAC 3,E↔PVT 2,3↔DAC 2,V1
01900		SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
02000		PCW 2,3↔DAC 2,E↔CAME 2,3↔GO L1
02100	
02200	;CLOSE THE TOP.
02300		SETQ(E,{MKFE,V1,FACE,V2})
02400		NFACE 1,1↔DAC 1,FNEW
02500		SOSG NN↔GO L3
02600	
02700	;FOLLOW DOWN BOTH SIDES.
02800	L2:	CALL(ECCW,E,FNEW)↔SETQ(V1,{OTHER,1,V1})
02900		CALL(ECW,E,FNEW)↔SETQ(V2,{OTHER,1,V2})
03000		SETQ(E,{MKFE,V2,FNEW,V1})
03100		SOSLE NN↔GO L2
03200	
03300	;UPDATE THE FIRST EDGE OF THE FACE.
03400	L3:	LAC 2,ARG2↔PED 1,2
03500		CALL(ECCW,1,2)↔PED. 1,2
03600		LAC 1,2↔POP2J
03700	
03800	COMMENT .	⊗	⊗-------⊗		⊗-------⊗
03900		      + |	|	|		|	|
04000		PED(F)	|	|	|		|	|PED(F)'
04100		      - |	|	|		|	|
04200			⊗	⊗	⊗	    V1→ ⊗-------⊗ ←V2
04300		      + |	|	|		|	|
04400			|	| FNEW	| F below	|	|
04500		      - |	|	|		|	|
04600			⊗	⊗	⊗		⊗ FNEW 	⊗
04700		      + |	|	|		|	|
04800			|	|	|		|	|
04900		      - |	|	|		|	|
05000			⊗	⊗-------⊗		⊗-------⊗	.
05100	DECLARE{FACE,FNEW,NN,V1,V2,E}
05200	BEND;2/7/73-------------------------------------------------------
     

00100	SUBR(ROTCOM)FACE--------------------------------------------------
00200	BEGIN ROTCOM;SOLID OF ROTATION COMLETION - BGB -8 FEB 1973.
00300		ACCUMULATORS{F,E,E0,M,N}
00400		LAC F,ARG1↔DAC F,FACE↔TEST F,FBIT↔POP1J
00500		NCNT N,F↔DACM N,NN↔SKIPN↔POP1J
00600	
00700	;COUNT THE EDGES IN THIS FACE.
00800		LACI M,1↔PED E,F↔DAC E,E0↔DAC E,EDGE
00900	L1:	SETQ(E,{ECCW,E,F})
01000		CAME E,E0↔AOJA M,L1
01100	
01200	;SKIP AROUND THE NORTH POLE CAP.
01300		ASH M,-1↔SUB M,NN
01400		SETQ(V1,{VCW,EDGE,FACE})
01500		LAC 1,EDGE
01600	L2:	CALL(ECW,1,FACE)↔SOJG M,L2
01700		SETQ(V2,{VCW,1,FACE})
01800		SETQ(EDGE,{MKFE,V2,FACE,V1})	;CLOSE THE TOP OF THE GAP.
01900	
02000	;FOLLOW DOWN THE GAP.
02100	L3:	CALL(ECCW,EDGE,FACE)↔SETQ(V1,{OTHER,1,V1})
02200		CALL(ECW,EDGE,FACE)↔SETQ(V2,{OTHER,1,V2})
02300		SETQ(EDGE,{MKFE,V2,FACE,V1})
02400		SOSLE NN↔GO L3
02500		SETZ↔LAC 1,FACE↔NCNT. 0,1
02600		POP1J
02700	COMMENT .
02800		⊗---⊗---⊗----⊗---⊗
02900		|      GAP	 |	← POLE CAP
03000		|       ↓ 	 |
03100		⊗-----⊗←←←←⊗-----⊗	← ARTIC CIRCLE
03200	       PED(F)→|    |
03300		      |    |
03400		  V1' ⊗←←←←⊗ V2'
03500		      | F  |
03600		      |    |
03700	        ⊗-----⊗    ⊗-----⊗	← ANTARTIC CIRCLE.
03800	
03900	DECLARE{FACE,EDGE,V1,V2,NN}
04000	BEND;2/8/73-------------------------------------------------------
     

00100	SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
00200	BEGIN PYRAMID
00300	
00400		LAC 1,ARG1↔TEST 1,VBIT↔GO L2
00500	;VERTEX ARGUMENT - GIVEN THE PEAK FORM THE BASE.
00600		DAC 1,V
00700		PED 2,1↔DAC 2,E0↔DAC 2,E2
00800		SETQ(V2,{OTHER,E2,V})
00900	L1:	LAC E2↔DAC E1
01000		LAC V2↔DAC V1
01100		SETQ(E2,{ECCW,E1,V})
01200		SETQ(V2,{OTHER,E2,V})
01300		CALL(LINKED,V1,V2)↔JUMPE 1,[	;WHEN NOT LINKED.
01400		CALL(FCCW,E1,V)
01500		CALL(MKFE,V1,1,V2)↔GO .+1]
01600		LAC E2↔CAME E0↔GO L1
01700		LAC 1,ARG1↔POP1J
01800		DECLARE{V,V1,V2,E0,E1,E2}
01900	
02000	;FACE ARGUMENT - GIVEN THE BASE FORM THE PEAK.
02100	L2:	DAC 1,F↔TEST 1,FBIT↔POP1J
02200		SETZM X↔SETZM Y↔SETZM Z↔SETZM N
02300		PED 2,1↔DAC 2,E↔DAC 2,E0
02400		SETQ(V0,{VCW,E0,F})
02500		SETQ(PEAK,{MKEV,F,V0})
02600	L3:	SETQ(V,{VCCW,E,F})
02700		LAC XWC(1)↔FADRM X
02800		LAC YWC(1)↔FADRM Y
02900		LAC ZWC(1)↔FADRM Z
03000		AOS N↔CAMN 1,V0↔GO L4
03100		SETQ(E,{ECCW,E,F})
03200		CALL(MKFE,PEAK,F,V)
03300		GO L3
03400	L4:	LAC 1,PEAK↔LAC 2,N↔FLOAT 2,
03500		LAC X↔FDVR 2↔DAC XWC(1)
03600		LAC Y↔FDVR 2↔DAC YWC(1)
03700		LAC Z↔FDVR 2↔DAC ZWC(1)
03800		POP1J
03900		DECLARE{PEAK,F,E,V0,X,Y,Z,N}
04000	
04100	BEND;2/8/73-------------------------------------------------------
     

00100	SUBR(REMOVF)FACE-------------------------------------------------
00200	BEGIN REMOVE; REMOVE A FACE FROM A POLYHEDRON - BGB - 7 FEB 1973.
00300		LAC 1,ARG1↔TEST 1,FBIT↔POP1J↔DAC 1,F
00400		PED 2,1↔DAC 2,E
00500		SETQ(V0,{VCW,E,F})
00600		SETQ(V,{VCCW,E,F})↔SLACI XWC(1)↔LAPI X↔BLT Z
00700		SETQ(A,{ECCW,E,F})
00800		SETQ(F,{KLFE,E})
00900		LACI 1↔DAC N
01000	L1:	LAC 1,A↔DAC 1,E
01100		PVT 0,1↔CAMN 0,V↔GO[CALL(INVERT,E)↔GO .+1]
01200		SETQ(A,{ECCW,A,F})
01300		SETQ(V,{KLVE,E})
01400		LAC XWC(1)↔FADRM X
01500		LAC YWC(1)↔FADRM Y
01600		LAC ZWC(1)↔FADRM Z↔AOS N
01700		CAME 1,V0↔GO L1
01800	;PLACE VERTEX AT CENTER OF DECEASED FACE.
01900		LAC 2,N↔FLOAT 2,
02000		LAC X↔FDVR 2↔DAC XWC(1)
02100		LAC Y↔FDVR 2↔DAC YWC(1)
02200		LAC Z↔FDVR 2↔DAC ZWC(1)
02300		POP1J
02400	DECLARE{F,E,V,V0,A,X,Y,Z,N}
02500	BEND;2/10/73-----------------------------------------------------
     

00100	SUBR(FVDUAL)BODY-------------------------------------------------
00200	BEGIN FVDUAL; FACE-VERTEX DUAL - BGB - 20 FEBRUARY 1973.
00300		ACCUMULATORS{B,F,E,V,E0,X,Y,Z,I}
00400		LAC B,ARG1↔TEST B,BBIT↔POP1J
00500	
00600	;FOR ALL THE FACES OF THE BODY.
00700		LAC F,B
00800	L1:	PFACE F,F↔TEST F,FBIT↔GO L3
00900		SETZB X,Y↔SETZB Z,I
01000		PED E,F↔DAC E,E0
01100	
01200	;COMPUTE CENTER OF EACH FACE.
01300	L2:	SETQ(V,{VCCW,E,F})
01400		SETQ(E,{ECCW,E,F})
01500		FADR X,XWC(V)↔FADR Y,YWC(V)↔FADR Z,ZWC(V)
01600		AOS I
01700		CAME E,E0↔GO L2
01800	
01900	;CONVERT FACES INTO VERTICES.
02000		FLOAT I,↔FDVR X,I↔FDVR Y,I↔FDVR Z,I
02100		DAC X,XWC(F)↔DAC Y,YWC(F)↔DAC Z,ZWC(F)
02200		LAC 1(F)↔DAC 3(F)↔SLACI(VBIT)↔DAC(F)
02300		GO L1
02400	
02500	;CONVERT VERTICES INTO FACES.
02600	L3:	LAC V,ARG1↔LACI 1,2↔LAC E,ARG1
02700	L4:	PVT V,V↔TEST V,VBIT↔GO L5
02800		LAC 3(V)↔DAC 1(V)↔DIP 1,(V)↔GO L4
02900	
03000	;TURN ALL THE EDGES OVER AND INSIDE OUT.
03100	L5:	PED E,E↔TEST E,EBIT↔GO L6
03200		LAC 1(E)↔EXCH 3(E)↔DAC 1(E)
03300		MOVSS 1(E)
03400		MOVS 4(E)↔MOVE 1,5(E)
03500		DAC 1,4(E)↔DAC 5(E)
03600		GO L5
03700	
03800	L6:	LAC B,ARG1↔LAC 1(B)↔EXCH 3(B)↔DAC 1(B)
03900		POP1J
04000	BEND;2/10/73-----------------------------------------------------
     

00100	END
00200	EULER.FAI - EOF.